home *** CD-ROM | disk | FTP | other *** search
/ CD ROM Paradise Collection 4 / CD ROM Paradise Collection 4 1995 Nov.iso / program / swagd_f.zip / ENTRY.SWG / 0022_Excellent ReadPattern.pas < prev    next >
Pascal/Delphi Source File  |  1995-02-28  |  9KB  |  226 lines
  1. Procedure ReadP (Var NewIn : String; OldIn : String; X,Y,Colr : Byte;
  2.                  FChar : Char; ValidChars : ChSet; Patrn : String);
  3.  
  4.               (* NewIn         = Variable containing data entered by user
  5.                  OldIn         = Default input string
  6.                  X,Y           = Coordinates to begin reading
  7.                  FChar         = Fill character at End-of-String
  8.                  ValidChars    = Set of Char of characters valid for input
  9.                                  (in some cases is redundant)
  10.                  Patrn         = String containing three different chars:
  11.                                         'X's for blank space (no data)
  12.                                         '#'s for numbers only
  13.                                         '@'s for alpha characters only
  14.                                         '%'s for both alpha & numeric
  15. characters              *)
  16.  
  17.   (* When calling ReadP, the prompt should already be on-screen.  X,Y locates
  18.      the point to begin the reading.  When ReadP returns a value in NewIn,
  19.      please note that a pattern of '###X###X####' will be returned looking like
  20.      '##########'.  The X's do not denote a space in the final string.  ie:
  21.  
  22.                     Please Enter Your Phone Number: (403) 123-4567
  23.  
  24.      will be returned in NewIn as 4031234567.  The pattern would have resembled
  25.      the example above.
  26.  
  27.      ** NOTE **  There are functions/procedures required to run this procedure.
  28.                  They are:
  29.                                 GetCursor (not necessary)
  30.                                 SetCursor (not necessary)
  31.                                 WriteP (pattern-writing routine, see next few
  32.                                         posts, is necessary)
  33.  
  34.      A demo program is included at the bottom of the message.
  35.  
  36.   *)
  37.  
  38.   (* Standard disclaimer: I'm not liable for anything this procedure does
  39.                           outside the original purpose of the procedure.  If
  40.                           something bad happens, let me know, but that's all
  41.                           I can do.
  42.   *)
  43.  
  44. Var
  45.    CurX, StLen, PatX, NumXs, MaxLen,
  46.    Tmp                                  : Byte;
  47.    DefChars                             : Set Of Char;
  48.    OldCursor                            : Word;
  49.  
  50. Begin
  51.      Tmp := 0;
  52.      For I := 1 To Length (Patrn) Do
  53.          If Patrn[I] = 'X' Then
  54.             Inc (Tmp);
  55.      If Length (OldIn) > Length (Patrn)-Tmp Then
  56.         OldIn := Copy (OldIn,1,Length (Patrn)-Tmp);
  57.      WriteP (OldIn,X,Y,HiColr,FChar,Patrn);
  58.      InStr := OldIn;
  59.      StLen := Length (OldIn);
  60.      NumXs := 0;
  61.      For I := 1 To StLen Do
  62.          If Patrn[I] = 'X' Then
  63.             Inc (NumXs);
  64.      CurX := StLen+X+NumXs;
  65.      PatX := StLen+NumXs+1;
  66.      If PatX = 0 Then
  67.      Begin
  68.           PatX := 1;
  69.           CurX := X;
  70.      End;
  71.      DefChars := ValidChars;
  72.      MaxLen := Length (Patrn);
  73.      OldCursor := GetCursor;
  74.      Repeat
  75.            If PatX = 0 Then
  76.            Begin
  77.                 PatX := 1;
  78.                 CurX := X;
  79.            End;
  80.            While Patrn[PatX] = 'X' Do
  81.            Begin
  82.                 Inc (PatX);
  83.                 Inc (CurX);
  84.            End;
  85.            NumXs := 0;
  86.            For I := 1 To PatX Do
  87.                If Patrn[I] = 'X' Then
  88.                   Inc (NumXs);
  89.            If InsOn Then
  90.               SetCursor (DefaultCursor)
  91.            Else
  92.                SetCursor (BlockCursor);
  93.            GotoXY (CurX,Y);
  94.            Case Patrn[PatX] Of
  95.                 '#': ValidChars := NumChars;
  96.                 '@': ValidChars := AlphaChars;
  97.                 '%': ValidChars := NumChars + AlphaChars;
  98.            End;
  99.            ValidChars := ValidChars + [#8,#13,#210,#211] + HKeySet + FuncKeys +
  100.                                       MenuKeys + ArrowKeys;
  101.            Repeat
  102.                  Ch := ReadKey;
  103.            Until Ch In ValidChars;
  104.            SetCursor (OldCursor);
  105.            Case Ch Of
  106.                 #8:
  107.                 Begin
  108.                      If PatX >= 2 Then
  109.                      Begin
  110.                           If Patrn[PatX-1] = 'X' Then
  111.                           Begin
  112.                                While (Patrn[PatX-1] = 'X') And (PatX > 1) Do
  113.                                Begin
  114.                                     Dec (PatX);
  115.                                     Dec (CurX);
  116.                                End;
  117.                                Dec (PatX);
  118.                                Dec (CurX);
  119.                           End
  120.                           Else
  121.                           Begin
  122.                                Dec (CurX);
  123.                                Dec (PatX);
  124.                           End;
  125.                           If (CurX >= X) And (Length (InStr) > 0) Then
  126.                           Begin
  127.                                NumXs := 0;
  128.                                For I := 1 To PatX Do
  129.                                    If Patrn[I] = 'X' Then
  130.                                       Inc (NumXs);
  131.                                Delete (InStr,PatX-NumXs,1);
  132.                           End;
  133.                      End;
  134.                 End;
  135.                 #203: { Left arrow }
  136.                 Begin
  137.                      If CurX > X Then
  138.                         If Patrn[PatX-1] <> 'X' Then
  139.                         Begin
  140.                              Dec (CurX);
  141.                              Dec (PatX);
  142.                         End
  143.                         Else
  144.                         Begin
  145.                              While Patrn[PatX-1] = 'X' Do
  146.                              Begin
  147.                                   Dec (CurX);
  148.                                   Dec (PatX);
  149.                              End;
  150.                              Dec (CurX);
  151.                              Dec (PatX);
  152.                         End;
  153.                      If PatX < 1 Then
  154.                      Begin
  155.                           CurX := X;
  156.                           PatX := 1;
  157.                      End;
  158.                 End;
  159.                 #205: { Right arrow }
  160.                       If PatX-NumXs <= Length (InStr) Then
  161.                          If Patrn[PatX+1] <> 'X' Then
  162.                          Begin
  163.                               Inc (CurX);
  164.                               Inc (PatX);
  165.                          End
  166.                          Else
  167.                          Begin
  168.                               Inc (CurX);
  169.                               Inc (PatX);
  170.                               While Patrn[PatX] = 'X' Do
  171.                               Begin
  172.                                    Inc (CurX);
  173.                                    Inc (PatX);
  174.                               End;
  175.                          End;
  176.                 #199: { Home }
  177.                 Begin
  178.                      CurX := X;
  179.                      PatX := 1;
  180.                 End;
  181.                 #207: { End }
  182.                 Begin
  183.                      PatX := Length (InStr)+1;
  184.                      For I := 1 To PatX Do
  185.                          If Patrn[I] = 'X' Then
  186.                             Inc (PatX);
  187.                      CurX := PatX+X-1;
  188.                 End;
  189.                 #210: { Insert }
  190.                       InsOn := InsOn XOr True;
  191.                 #211: { Delete }
  192.                       Delete (InStr,PatX-NumXs,1);
  193.                 #65..#90,
  194.                 #97..#122, { Alphabet }
  195.                 #48..#57,  { Numbers }
  196.                 #91..#96,
  197.                 #32..#47,
  198.                 #58..#64:  { Other chars }
  199.                 Begin
  200.                      If (CurX-X < MaxLen) And (((Length (InStr) < MaxLen) And
  201.                         (InsOn)) Or ((Not InsOn))) Then
  202.                      Begin
  203.                           If InsOn Then
  204.                                Insert (Ch,InStr,PatX-NumXs)
  205.                           Else
  206.                           Begin
  207.                                If PatX-NumXs > Length (InStr) Then
  208.                                   Insert (Ch,InStr,PatX-NumXs)
  209.                                Else
  210.                                    InStr[PatX-NumXs] := Ch;
  211.                           End;
  212.                           Inc (CurX);
  213.                           Inc (PatX);
  214.                      End;
  215.                 End;
  216.            End;
  217.            If Length (InStr) > Length (Patrn) Then
  218.               InStr[0] := Chr (Length (Patrn));
  219.            WriteP (InStr,X,Y,Colr,FChar,Patrn);
  220.      Until (Ch = #13) Or (Ch = #27);
  221.      If Ch = #27 Then
  222.         NewIn := '';
  223.      If Ch = #13 Then
  224.         NewIn := InStr;
  225. End;
  226.